home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / CBoot / thread.em < prev    next >
Lisp/Scheme  |  1993-07-14  |  4KB  |  142 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: threads.em
  4. ;; Date: Mon Jun 28 17:18:22 1993
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;  Higher level thread operations.
  9. ;;  Mostly deal with signals, initialization and printing
  10.  
  11. (defmodule thread
  12.   (defs
  13.    extras0
  14.    macros0
  15.    telos1
  16.    init
  17.    streams1
  18.    (rename ((open-primitive-semaphore lock)
  19.         (close-primitive-semaphore unlock))
  20.        sems)
  21.    threads
  22.    )
  23.   ()
  24.   
  25.   (expose threads)
  26.  
  27.   (export <thread> threadp thread-reschedule current-thread thread-start
  28.       thread-value <thread-condition> <wrong-thread-continue>
  29.       lock-with-signals make-thread thread-signal
  30.       <interrupt>)
  31.   
  32.   (defclass <thread-condition> (<condition>)
  33.     ()
  34.     )
  35.  
  36.   (defclass <wrong-thread-continue> (<condition>)
  37.     ()
  38.     )
  39.   
  40.   (defclass <interrupt> (<thread-condition>)
  41.     ((flags initarg flags reader interrupt-flags))
  42.     )
  43.  
  44.   (defun lock-with-signals (isem)
  45.     (or (lock isem)
  46.     (progn (handle-pending-signals)
  47.            (lock-with-signals isem))))
  48.  
  49.   (defun thread-reschedule ()
  50.     (internal-thread-reschedule)
  51.     (handle-pending-signals))
  52.   
  53.   (defun thread-value (thread)
  54.     (let ((res (internal-thread-value thread)))
  55.       (format t "in thread value: ~a~%" res)
  56.       (if (car res) (cdr res)
  57.     (progn (handle-pending-signals)
  58.            (thread-value thread)))))
  59.   
  60.   ;; Use of this function is depracated. Use it and hope.
  61.   ;; don't, and wonder.
  62.  
  63.   (defun thread-suspend ()
  64.     (or (internal-thread-suspend)
  65.     (progn (handle-pending-signals)
  66.            (thread-suspend))))
  67.  
  68.   ;; NB: it is impossible to raise a non-continuable error on a thread...
  69.   ;; Should wake up the thread if it is asleep.
  70.   ;; luckily, threads are always waiting or running, mod thread-suspend.
  71.   ;; Thread suspend ain't part of the system, so all is cool.
  72.  
  73.   (defun thread-signal (cond fn thread)
  74.     (let ((sem (car (thread-signals thread))))
  75.       (lock sem)
  76.       ((setter thread-signals) thread 
  77.        (nconc (thread-signals thread) (cons cond fn)))
  78.       (thread-set-signalled thread t)
  79.       (unlock sem))
  80.     (if (eq (current-thread) thread)
  81.     (handle-pending-signals)
  82.       (thread-reschedule)))
  83.  
  84.   (defun handle-pending-signals ()
  85.     (let* ((thread (current-thread))
  86.        (thread-signals (thread-signals thread)))
  87.       (lock (car thread-signals))
  88.       (let ((lst (copy-list (cdr thread-signals))))
  89.     ((setter cdr) thread-signals nil)
  90.     (thread-set-signalled thread nil)
  91.     (unlock (car thread-signals))
  92.     (mapcar (lambda (cond)
  93.           (format (standard-error-stream) 
  94.               "dealing with: ~a~%" cond)
  95.           (let/cc next 
  96.               (internal-signal cond next)))
  97.         lst)
  98.     nil)))
  99.   
  100.   (defun internal-thread-signal (thread flags)
  101.     (print (list thread flags) (standard-error-stream))
  102.     (thread-signal (make <interrupt> 'flags flags) 
  103.            nil
  104.            thread))
  105.     
  106.  
  107.   (set-sig-handler internal-thread-signal)
  108.   (set-bc-global 5 internal-thread-signal)
  109.  
  110.   (defmethod allocate ((x <thread-class>) lst)
  111.     (generic_allocate_instance\,Thread_Class x lst))
  112.  
  113.   (defmethod initialize ((x <thread>) lst)
  114.     (let ((new (call-next-method)))
  115.       (initialize-thread new lst)
  116.       ((setter thread-signals) new 
  117.        (cons (make-primitive-semaphore) nil))
  118.       new))
  119.   
  120.   (defun make-thread (fun . junk)
  121.     (apply make <thread> 'function fun junk))
  122.  
  123.   ((setter thread-signals) (current-thread)
  124.    (cons (make-primitive-semaphore) nil))
  125.   
  126.   (add-method generic-prin 
  127.           (make <method>
  128.             'signature (list <thread> <object>)
  129.             'function (method-lambda (thread s)
  130.                          (let ((state (thread-state thread)))
  131.                            (format s "#<~a: ~u ~a ~a>"
  132.                                (symbol-unbraced-name (class-name (class-of thread)))
  133.                                thread state
  134.                                (if (eq state 'returned)
  135.                                (thread-value thread) 
  136.                              "{undetermined}"))))))
  137.   
  138.   
  139.  
  140.   ;; end module
  141.   )
  142.